
 (* UCSD PASCAL I.5 P-SYSTEM "LIBRARIAN" *)

 PROGRAM PLIBRARIAN;

 (*$U-*)
	
 CONST
      MAXSEG = 15;       (*MAX CODE SEGMENT NUMBER*)

 TYPE
                                         (*CODE SEGMENT LAYOUTS*)

      SEGRANGE = 0..MAXSEG;
      SEGDESC = RECORD
                  DISKADDR: INTEGER;     (*REL BLK IN CODE...ABS IN SYSCOM^*)
                  CODELENG: INTEGER      (*# BYTES TO READ IN*)
                END (*SEGDESC*) ;
                                         (*SYSTEM COMMUNICATION AREA*)
                                         (*SEE INTERPRETERS...NOTE  *)
                                         (*THAT WE ASSUME BACKWARD  *)
                                         (*FIELD ALLOCATION IS DONE *)
      SYSCOMREC = RECORD
                    IORSLT: INTEGER ;    (*RESULT OF LAST IO CALL*)
                    XEQERR: INTEGER;     (*REASON FOR EXECERROR CALL*)
                    SYSUNIT: INTEGER;    (*PHYSICAL UNIT OF BOOTLOAD*)
                    BUGSTATE: INTEGER;   (*DEBUGGER INFO*)
                    GDIRP: INTEGER;
                    LASTMP,STKBASE,BOMBP: INTEGER;
                    MEMTOP,SEG,JTAB: INTEGER;
                    BOMBIPC: INTEGER;    (*WHERE XEQERR BLOWUP WAS*)
                    HLTLINE: INTEGER;    (*MORE DEBUGGER STUFF*)
                    BRKPTS: ARRAY [0..3] OF INTEGER;
                    RETRIES: INTEGER;    (*DRIVERS PUT RETRY COUNTS*)
                    EXPANSION: ARRAY [0..8] OF INTEGER;
                    HIGHTIME,LOWTIME: INTEGER;
                    MISCINFO: PACKED RECORD
                                NOBREAK,STUPID,SLOWTERM,
                                HASXYCRT,HASLCCRT,HAS8510A,HASCLOCK: BOOLEAN
                              END;
                    CRTTYPE: INTEGER;
                    CRTCTRL: PACKED RECORD
                               RLF,NDFS,ERASEEOL,ERASEEOS,HOME,ESCAPE: CHAR;
                               BACKSPACE: CHAR;
                               FILLCOUNT: 0..255;
                               EXPANSION: PACKED ARRAY [0..3] OF CHAR
                             END;
                    CRTINFO: PACKED RECORD
                               WIDTH,HEIGHT: INTEGER;
                               RIGHT,LEFT,DOWN,UP: CHAR;
                               BADCH,CHARDEL,STOP,BREAK,FLUSH,EOF: CHAR;
                               ALTMODE,LINEDEL: CHAR;
                               EXPANSION: PACKED ARRAY [0..5] OF CHAR
                             END;
                    SEGTABLE: ARRAY [SEGRANGE] OF
                                RECORD
                                  CODEUNIT: INTEGER;
                                  CODEDESC: SEGDESC
                                END
                  END (*SYSCOM*);

 VAR
     SYSCOM: ^SYSCOMREC;                 (*MAGIC PARAM...SET UP IN BOOT*)

 SEGMENT PROCEDURE LIBRARIAN(III,JJJ: INTEGER);

 CONST
   WINDOW = 2;
   ERROR = 23;
   MARKCODE = 15;
   MARKIN = 5;


 TYPE
      BLOCK0P = ^BLOCK0;
      BLOCK0 = RECORD
                 SEGDSC: ARRAY [SEGRANGE] OF SEGDESC;
                 SEGNAME: ARRAY [SEGRANGE] OF
                            PACKED ARRAY [0..7] OF CHAR;
                 SEGKIND: ARRAY [SEGRANGE] OF INTEGER;
                 EXTRA: ARRAY [SEGRANGE] OF INTEGER;
                 FILLER: ARRAY [1..88] OF INTEGER;
                 NOTICE: STRING[79]
               END;


 VAR NBLOCKS,RSLT,OUTBLOCK: INTEGER;
     BUF: BLOCK0P;
     DSEG,SSEG: SEGRANGE;
     PL,TITLE: STRING;
     CODETBL: BLOCK0;
     CODE,INFILE: FILE;

 PROCEDURE NEWLINKER;

 VAR CCH: CHAR;
     INTBL: BLOCK0P;
     NTITLE: STRING;
     CODETABLE: BLOCK0P;
     PL: STRING;

 PROCEDURE PROMPT(AT: INTEGER);
 BEGIN
   GOTOXY(0,AT);
   IF AT = ERROR THEN WRITE(CHR(7));
   WRITE(PL);
   WITH SYSCOM^.CRTCTRL DO WRITE(ESCAPE,ERASEEOL);
 END;

 FUNCTION CHECKIO:BOOLEAN;
 VAR RSLT:INTEGER;
 BEGIN
   CHECKIO:=IORESULT=0;
   IF IORESULT <> 0 THEN
     BEGIN
       RSLT:=IORESULT;
       PL := 'I/O error # ';
       PROMPT(ERROR);
       WRITE(OUTPUT,RSLT);
     END;
 END; (* CHECKIO *)

 PROCEDURE OPENFILE;
 BEGIN
   REPEAT
     PL := 'Link Code File -> ';
     PROMPT(4);
     READLN(INPUT,NTITLE);
     IF LENGTH(NTITLE) > 0 THEN
       BEGIN
         TITLE := NTITLE;
         RESET(INFILE,NTITLE);
       END;
   UNTIL (CHECKIO) OR (LENGTH(NTITLE) = 0);
 END (*OPENFILE*) ;

 PROCEDURE DISPLAY(AT: INTEGER; WHAT: BLOCK0P);
 VAR
   T: INTEGER;
 BEGIN
   GOTOXY(0,AT);
   WITH WHAT^ DO
     FOR T := 0 TO 3 DO
       BEGIN
         WRITE(T:3,'-',SEGNAME[T],SEGDSC[T].CODELENG:6);
         WRITE(T+4:5,'-',SEGNAME[T+4],SEGDSC[T+4].CODELENG:6);
         WRITE(T+8:5,'-',SEGNAME[T+8],SEGDSC[T+8].CODELENG:6);
         WRITELN(T+12:5,'-',SEGNAME[T+12],SEGDSC[T+12].CODELENG:6)
       END;
   PL := 'Code file length - ';
   PROMPT(12);
   WRITE(OUTPUT,OUTBLOCK);
 END;


 PROCEDURE LINKCODE;
   VAR NBLOCKS: INTEGER;

   PROCEDURE LINKIT;

     PROCEDURE COPYLINKINFO(INFOBLK: INTEGER);
       VAR N, NRECS: INTEGER;
           DONE: BOOLEAN;
           REC: ARRAY [0..7] OF INTEGER;
           BUF: ARRAY [0..31, 0..7] OF INTEGER;

         PROCEDURE GETREC;
         BEGIN
           IF NRECS = 0 THEN
             IF BLOCKREAD(INFILE, BUF, 1, INFOBLK) <> 1 THEN
               BEGIN
                 PL := 'Link info read err';
                 PROMPT(ERROR);
                 DONE := TRUE
               END
             ELSE
               IF BLOCKWRITE(CODE, BUF, 1, OUTBLOCK) <> 1 THEN
                 BEGIN
                   PL := 'Code file overflow';
                   PROMPT(ERROR);
                   DONE := TRUE
                 END
               ELSE
                 BEGIN
                   OUTBLOCK := OUTBLOCK+1;
                   INFOBLK := INFOBLK+1;
                   NRECS := 32
                 END;
           IF NOT DONE THEN
             REC := BUF[32-NRECS];
           NRECS := NRECS-1
         END { GETREC } ;

     BEGIN { COPYLINKINFO }
       NRECS := 0; DONE := FALSE;
       REPEAT
         GETREC;
         IF NOT (REC[4] IN [0..14]) THEN
           BEGIN
             PL := 'Bad link info';
             PROMPT(ERROR);
             REC[4] := 0
           END;
         DONE := REC[4] = 0;
         IF NOT DONE THEN
           IF REC[4] IN [1..5,13,14] THEN
             BEGIN { COPY REF LIST }
               N := (REC[6]+7) DIV 8;
               WHILE N > 0 DO
                 BEGIN GETREC; N := N-1 END
             END
       UNTIL DONE
     END { COPYLINKINFO } ;

     PROCEDURE COPYINTERFACE(START: INTEGER);
       CONST IMPLMTSY = 52;
       VAR J: INTEGER; { FIXED DECLARATION ORDER }
           S: INTEGER;
           O: INTEGER;
           N: PACKED ARRAY [0..7] OF CHAR;
           DONE: BOOLEAN;
           BUF: PACKED ARRAY [0..1023] OF CHAR;
     BEGIN
       IF (START <= 0) OR (START > 200) THEN
         EXIT(COPYINTERFACE);
       CODETABLE^.EXTRA[DSEG] := OUTBLOCK;
       DONE := FALSE;
       REPEAT
         IF BLOCKREAD(INFILE, BUF, 2, START) <> 2 THEN
           BEGIN
             PL := 'Interface read err';
             PROMPT(ERROR);
             DONE := TRUE
           END
         ELSE
           IF BLOCKWRITE(CODE, BUF, 2, OUTBLOCK) <> 2 THEN
             BEGIN
               PL := 'Interface write err';
               PROMPT(ERROR);
               DONE := TRUE
             END
           ELSE
             BEGIN
               START := START+2;
               OUTBLOCK := OUTBLOCK+2;
               J := 0;
               REPEAT
                 IF BUF[J] IN ['A'..'Z', 'a'..'z'] THEN
                   BEGIN
                     IDSEARCH(J,BUF);
                     DONE := S = IMPLMTSY;
                     IF DONE THEN
                       IF J < 510 THEN
                         OUTBLOCK := OUTBLOCK-1
                   END;
                 IF BUF[J] = CHR(13) THEN
                   IF BUF[J+1] = CHR(0) THEN
                     J := 1023;
                 J := J+1
               UNTIL DONE OR (J > 1023)
             END
       UNTIL DONE
     END { COPYINTERFACE } ;

     BEGIN
       WITH INTBL^,SEGDSC[SSEG] DO
         BEGIN
           NBLOCKS := (CODELENG+511) DIV 512;
           IF BLOCKREAD(INFILE,BUF^,NBLOCKS,DISKADDR) <> NBLOCKS THEN
             BEGIN
               PL := 'Error reading seg ';
               PROMPT(ERROR);
               WRITE(OUTPUT,SSEG)
             END
           ELSE
             IF BLOCKWRITE(CODE,BUF^,NBLOCKS,OUTBLOCK) <> NBLOCKS THEN
               BEGIN
                 PL := 'I/O error - no room on disk';
                 PROMPT(ERROR);
               END
             ELSE
               BEGIN
                 CODETABLE^.SEGNAME[DSEG] := SEGNAME[SSEG];
                 CODETABLE^.SEGDSC[DSEG].CODELENG := CODELENG;
                 CODETABLE^.SEGDSC[DSEG].DISKADDR := OUTBLOCK;
                 OUTBLOCK := OUTBLOCK+NBLOCKS;
                 IF (SEGKIND[SSEG] < 0) OR (SEGKIND[SSEG] > 4) THEN
                   SEGKIND[SSEG] := 0;
                 CODETABLE^.SEGKIND[DSEG] := SEGKIND[SSEG];
                 CODETABLE^.EXTRA[DSEG] := 0;
                 IF SEGKIND[SSEG] <> 0 THEN
                   COPYLINKINFO(DISKADDR+NBLOCKS);
                 IF (SEGKIND[SSEG] IN [3,4]) THEN
                   COPYINTERFACE(EXTRA[SSEG])
               END
         END;
       DISPLAY(MARKCODE,CODETABLE);
     END;

 FUNCTION CONFIRM: BOOLEAN;
   VAR
     N: INTEGER;
   BEGIN
     CONFIRM:=FALSE;
     (*get segment*)
     N:= 0;
     PL := '';
     PROMPT(WINDOW);
     REPEAT
       READ(CCH);
       IF CCH = CHR(8) THEN
         N := N DIV 10;
       IF CCH IN ['0'..'9'] THEN
         N := N*10 + ORD(CCH)-ORD('0')
     UNTIL NOT (CCH IN [CHR(8),'0'..'9']);
     IF CCH <> ' ' THEN (*probably N or Q*)
       EXIT(CONFIRM);
     IF N IN [0..MAXSEG] THEN (*good segment number*)
       WITH INTBL^ DO
         IF SEGDSC[N].CODELENG > 0 THEN (*any chunk of code*)
           BEGIN
             SSEG := N;
             REPEAT
               PL := 'Seg to link into? ';
               PROMPT(WINDOW);
               READ(DSEG)
             UNTIL DSEG IN [0..MAXSEG];
             READ(CCH); { EAT XTRA CHAR }
             CCH := 'Y'; (* TRICK THE REPLACEMENT BELOW *)
             IF (CODETABLE^.SEGDSC[DSEG].CODELENG <> 0) THEN (*linking again*)
               BEGIN
                 PL :=
 'WARNING - Segment already linked.  Please Reconfirm (y/n) - ';
                 PROMPT(WINDOW);
                 READ(INPUT,CCH);
                 WRITELN(OUTPUT);
               END;
             CONFIRM := CCH IN ['Y','y']
           END;
   END; (* CONFIRM *)

 BEGIN
   IF LENGTH(NTITLE)>0 THEN
     IF BLOCKREAD(INFILE,INTBL^,1,0) = 1 THEN
       DISPLAY(MARKIN,INTBL)
     ELSE
       BEGIN
         RSLT:=IORESULT;
         PL := 'Read error # ';
         PROMPT(ERROR);
         WRITE(OUTPUT,RSLT);
       END;
   PL :=
 'Segment # to link and <space>, N(ew file, Q(uit, A(bort';
   PROMPT(0);
   REPEAT
     IF CONFIRM THEN LINKIT;
   UNTIL CCH IN ['N','Q','A','n','q','a'];
   CLOSE(INFILE)
 END (*LINKCODE*) ;

 BEGIN
   PAGE(OUTPUT);
   PL := 'Pascal System Librarian';
   PROMPT(0);
   NEW(CODETABLE);
   NEW(INTBL);
   PL := 'Output code file -> ';
   REPEAT
     PROMPT(11);
     READLN(INPUT,TITLE);
     IF LENGTH(TITLE) = 0 THEN EXIT(LIBRARIAN)
     ELSE REWRITE(CODE,TITLE)
   UNTIL (LENGTH(TITLE) = 0) OR (CHECKIO);
   OUTBLOCK := 1; NEW(BUF);
   IF SIZEOF(BLOCK0) <> 512 THEN
     HALT;
   FILLCHAR(CODETABLE^, SIZEOF(BLOCK0), 0);
   WITH CODETABLE^ DO
     FOR DSEG := 0 TO MAXSEG DO
       SEGNAME[DSEG] := '        ';
   REPEAT
     OPENFILE;
     LINKCODE;
   UNTIL CCH IN ['Q','q','A','a'];
   IF CCH IN ['A','a'] THEN EXIT(LIBRARIAN);
   PL := 'Notice? ';
   PROMPT(23);
   READLN(CODETABLE^.NOTICE);
   IF BLOCKWRITE(CODE,CODETABLE^,1,0) = 1 THEN
     CLOSE(CODE,LOCK)
   ELSE
     WRITELN(OUTPUT,'Code write error ')
 END { NEWLINKER } ;

 {
 FUNCTION CHECKIO:BOOLEAN;
 VAR RSLT:INTEGER;

 BEGIN
   CHECKIO:=IORESULT=0;
   IF IORESULT <> 0 THEN
     BEGIN
     RSLT:=IORESULT;
     WRITELN(OUTPUT,'I/O error # ',RSLT);
     END;
 END; (* CHECKIO *)

 FUNCTION OPENFILE: BOOLEAN;
 BEGIN
   REPEAT
     WRITE(OUTPUT,'Link Code File? '); READLN(INPUT,TITLE);
     IF LENGTH(TITLE) > 0 THEN RESET(INFILE,TITLE);
   UNTIL (CHECKIO) OR (LENGTH(TITLE) = 0);
   OPENFILE := LENGTH(TITLE) > 0
 END (*OPENFILE*) ;

 PROCEDURE LINKCODE;
   VAR NBLOCKS: INTEGER;
       INTBL: BLOCK0;

   FUNCTION CONFIRM:BOOLEAN;
   VAR CH:CHAR;
   BEGIN
     CONFIRM:=FALSE;
     WITH INTBL DO
       BEGIN
       IF SEGDSC[DSEG].CODELENG > 24 THEN
         BEGIN
         WRITE(OUTPUT,'Linking ',SEGNAME[DSEG],'.  Please Confirm (y/n)');
         READ(INPUT,CH);
         WRITELN(OUTPUT);
         IF (CODETBL.SEGDSC[DSEG].CODELENG <> 0) AND (CH IN ['Y','y']) THEN
           BEGIN
           WRITE(OUTPUT,
 'WARNING - segment already linked.  Please Reconfirm');
           READ(INPUT,CH);
           WRITELN(OUTPUT);
           END;
         CONFIRM := CH IN ['y','Y'];
         END;
       END;
   END; (* CONFIRM *)

 BEGIN
   IF BLOCKREAD(INFILE,INTBL,1,0) = 1 THEN
     BEGIN
       WITH INTBL DO
         FOR DSEG := 0 TO MAXSEG DO
             WITH SEGDSC[DSEG] DO
               IF CONFIRM THEN
                 BEGIN NBLOCKS := (CODELENG+511) DIV 512;
                   IF BLOCKREAD(INFILE,BUF^,NBLOCKS,DISKADDR) <> NBLOCKS THEN
                     WRITELN(OUTPUT,'Error reading seg ',DSEG)
                   ELSE
                     IF BLOCKWRITE(CODE,BUF^,NBLOCKS,OUTBLOCK) <> NBLOCKS THEN
                       WRITELN(OUTPUT,'I/O error - no room on disk')
                     ELSE
                       BEGIN
                         WRITELN(OUTPUT,SEGNAME[DSEG],' Seg # ',DSEG,', Block ',
                                 OUTBLOCK,', ',CODELENG,' Bytes');
                         CODETBL.SEGNAME[DSEG] := SEGNAME[DSEG];
                         CODETBL.SEGDSC[DSEG].CODELENG := CODELENG;
                         CODETBL.SEGDSC[DSEG].DISKADDR := OUTBLOCK;
                         OUTBLOCK := OUTBLOCK + NBLOCKS
                       END
                 END
     END
   ELSE
     BEGIN
     RSLT:=IORESULT;
     WRITELN(OUTPUT,'Input file read error # ',RSLT);
     END;
   CLOSE(INFILE)
 END (*LINKCODE*) ;

 BEGIN
   IF NOT SYSCOM^.MISCINFO.SLOWTERM THEN NEWLINKER
   ELSE
     BEGIN
       REPEAT
         WRITE(OUTPUT,'Output code file? '); READLN(INPUT,TITLE);
         IF LENGTH(TITLE) > 0 THEN REWRITE(CODE,TITLE)
       UNTIL (LENGTH(TITLE) = 0) OR (CHECKIO);
       IF LENGTH(TITLE) > 0 THEN
         BEGIN OUTBLOCK := 1; NEW(BUF);
           WITH CODETBL DO
             FOR DSEG := 0 TO MAXSEG DO
               BEGIN  SEGNAME[DSEG] := '        ';
                 SEGDSC[DSEG].CODELENG := 0;
                 SEGDSC[DSEG].DISKADDR := 0
               END;
           WHILE OPENFILE DO LINKCODE;
           WRITE('Notice:');
           READLN(CODETBL.NOTICE);
           IF BLOCKWRITE(CODE,CODETBL,1,0) = 1 THEN CLOSE(CODE,LOCK)
           ELSE
             WRITELN(OUTPUT,'Code file write error ')
         END
     END
 }
 BEGIN
   NEWLINKER
 END { LIBRARIAN } ;

 BEGIN END.